home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tptc16.zip
/
TPCEXPR.INC
< prev
next >
Wrap
Text File
|
1993-01-04
|
14KB
|
625 lines
(*
* TPTC - Turbo Pascal to C translator
*
* (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
*
*)
(*
* expression parser
*
*)
function iscall(var lv: string255): boolean;
{see if the given lvalue is a function call or not}
begin
iscall := lv[length(lv)] = ')';
end;
function exprtype(var ex: string255): char;
{determine expression type and return the printf code for the type}
var
sym: symptr;
xt: char;
p: integer;
id: string40;
begin
if ex[1] = '''' then
xt := 'c'
else
if ex[1] = '"' then
xt := 's'
else
begin
ex[length(ex)+1] := #0;
p := 1;
while (ex[p] in ['a'..'z','A'..'Z','0'..'9']) do
inc(p);
id := copy(ex,1,p-1);
sym := locatesym(id);
if sym <> nil then
case sym^.symtype of
s_char: xt := 'c';
s_int: xt := 'd';
s_long: xt := 'D'; { calling routine should convert to "ld" }
s_double: xt := 'f';
s_string:
begin
p := length(id) + 1;
while (p < length(ex)) and (ex[p] in [' ',^I]) do
inc(p);
if (ex[p] = '[') and (sym^.suptype = ss_scalar) then
xt := 'c'
else
xt := 's';
end;
else xt := 'd';
end
else
if copy(ex,1,5) = 'scat(' then
xt := 's'
else
if copy(ex,1,5) = 'copy(' then
xt := 's'
else
if copy(ex,1,5) = 'ctos(' then
xt := 's'
else
if copy(ex,1,4) = 'chr(' then
xt := 'c'
else
if copy(ex,1,4) = 'ord(' then
xt := 'd'
else
xt := 'd' {all other kinds are defaulted to integer}
end;
exprtype := xt;
end;
function strtype(var ex: string255): boolean;
{see if the expression is a string data type or not}
begin
case exprtype(ex) of
's': strtype := true;
'c': strtype := true;
else strtype := false;
end;
end;
function psetof: string255;
{parse a literal set; returns the set literal translated into
the form: setof(.....)}
var
ex: string255;
begin
gettok; {consume the [}
ex := 'setof(';
repeat
if tok = '..' then {set ranges are passed as FROM,-2,TO}
begin {and are interpreted by inset()}
gettok;
ex := ex + ',THRU,';
end
else
if tok = ',' then
begin
gettok;
ex := ex + ',';
end
else
if tok <> ']' then
ex := ex + pexpr;
until tok = ']';
gettok; {consume the ]}
ex := ex + ',ENDSET)';
psetof := ex;
end;
function pterm: string255;
{parse an expression term; returns the translated expression term;
detects subexpressions, set literals and lvalues(variable names)}
var
ex: string255;
begin
(* translate NOT term into !term *)
if tok = 'NOT' then
begin
gettok;
pterm := '!' + pterm;
end
else
(* process pos(c,str) and pos(str,str) *)
if (tok = 'POS') then
begin
gettok; {consume the keyword}
gettok; {consume the (}
ex := pexpr;
if exprtype(ex) = 'c' then
ex := 'cpos(' + ex
else
ex := 'spos(' + ex;
gettok; {consume the ,}
ex := ex + ',' + pexpr;
gettok; {consume the )}
pterm := ex + ')';
end
else
(* process port/memory array references *)
if (tok = 'PORT') or (tok = 'PORTW') or
(tok = 'MEM') or (tok = 'MEMW') then
begin
if tok = 'PORT' then ex := 'inportb(' else
if tok = 'PORTW' then ex := 'inport(' else
if tok = 'MEM' then ex := 'peekb(' else
ex := 'peek(';
gettok; {consume the keyword}
gettok; {consume the [ }
repeat
ex := ex + pexpr;
if tok = ':' then
begin
gettok;
ex := ex + ',';
end;
until tok = ']';
gettok; {consume the ] }
pterm := ex + ')';
end
else
(* translate bitwise not (mt+) *)
if (tok = '?') or (tok = '~') or (tok = '\') then
begin
gettok;
pterm := '!' + pterm; {what is a bitwise NOT in c?}
end
else
(* process unary minus *)
if tok = '-' then
begin
gettok;
pterm := '-' + pterm;
end
else
(* pass numbers *)
if toktype = number then
begin
pterm := tok;
gettok;
end
else
(* pass strings *)
if toktype = strng then
begin
pterm := tok;
gettok;
end
else
(* pass sub expressions *)
if tok = '(' then
begin
gettok;
pterm := '(' + pexpr + ')';
gettok;
end
else
(* translate literal sets *)
if tok = '[' then
begin
pterm := psetof;
end
(* otherwise the term will be treated as an lvalue *)
else
pterm := plvalue;
end;
function pexpr {: string255};
{top level expression parser; parse and translate an expression and
return the translated expr}
var
ex: string255;
ty: char;
ex2: string255;
ty2: char;
procedure relop(newop: string40);
begin
gettok; {consume the operator token}
ex2 := pterm; {get the second term}
{use strcmp if either param is a string}
ty := exprtype(ex);
ty2 := exprtype(ex2);
if ty = 's' then
begin
if ty2 = 's' then
ex := 'strcmp(' + ex + ',' + ex2 + ') ' + newop + ' 0'
else
if ex2[1] = '''' then
ex := 'strcmp(' + ex + ',"' +
copy(ex2,2,length(ex2)-2) + '") ' + newop + ' 0'
else
ex := 'strcmp(' + ex + ',ctos(' + ex2 + ')) ' + newop + ' 0'
end
else
if ty = 'c' then
begin
if ty2 = 's' then
ex := 'strcmp(ctos(' + ex + '),' + ex2 + ') ' + newop + ' 0'
else
ex := ex + ' ' + newop + ' ' + ex2
end
else
ex := ex + ' ' + newop + ' ' + ex2;
end;
procedure addop;
procedure add_scat;
var
p: integer;
begin
ty := exprtype(ex);
ty2 := exprtype(ex2);
p := 7;
while ex[p] <> '"' do
p := succ(p);
p := succ(p);
{add literals to the control string if possible}
if (ex2[1] = '''') or (ex2[1] = '"') then
ex := copy(ex,1,p-2) + copy(ex2,2,length(ex2)-2) +
copy(ex,p-1,length(ex)-p+2)
else {add a parameter to the control string}
ex := copy(ex,1,p-2) + '%' + ty2 +
copy(ex,p-1,length(ex)-p+1) + ',' + ex2 + ')';
end;
begin
gettok; {consume the operator token}
ex2 := pterm; {get the second term}
if copy(ex,1,5) = 'scat(' then
add_scat
else
if strtype(ex) or strtype(ex2) then
begin
if (ex[1] = '''') or (ex[1] = '"') then
ex := 'scat("' + copy(ex,2,length(ex)-2) + '")'
else
ex := 'scat("%' + exprtype(ex) + '",' + ex + ')';
add_scat;
end
else
ex := ex + ' + ' + ex2;
end;
procedure mulop(newop: string40);
begin
gettok; {consume the operator token}
ex2 := pterm; {get the second term}
ex := ex + ' ' + newop + ' ' + ex2;
end;
begin
ex := pterm;
while true do
begin
(* process operators *)
if tok = '>' then relop(tok)
else if tok = '<' then relop(tok)
else if tok = '>=' then relop(tok)
else if tok = '<=' then relop(tok)
else if tok = '<>' then relop('!=')
else if tok = '=' then relop('==')
else if tok = '+' then addop
else if tok = '-' then mulop(tok)
else if tok = '*' then mulop(tok)
else if tok = '/' then mulop(tok)
else if tok = 'DIV' then mulop('/')
else if tok = 'MOD' then mulop('%')
else if tok = 'AND' then mulop('&&')
else if tok = 'OR' then mulop('||')
else if tok = 'SHR' then mulop('>>')
else if tok = 'SHL' then mulop('<<')
else if tok = 'XOR' then mulop('^')
else if tok = '&' then mulop(tok) {mt+}
else if tok = '!' then mulop('|') {mt+}
else if tok = '|' then mulop('|') {mt+}
else
(* translate the expr IN set operator *)
if tok = 'IN' then
begin
gettok;
ex := 'inset('+ex+', ' + pterm + ')';
end
else
(* ran out of legal expression operators; return what we found *)
begin
pexpr := ex;
exit;
end;
end;
end;
function plvalue{: string255};
{parse and translate an lvalue specification and return the translated
lvalue as a string}
var
lv: string255;
v: string255;
tv: string255;
pref: anystring;
idok: boolean;
sym: symptr;
func: symptr;
pvars:integer;
ind: string40;
begin
(* lvalues must begin with an identifier in pascal *)
if toktype <> identifier then
error('Identifier expected (plvalue)');
(* assign initial part of the lvalue *)
lv := ltok;
v := tok;
idok := false;
pref := '';
gettok;
sym := locatesym(lv);
if sym <> nil then
begin
{ if in_locals and past_marker then
pref := 'nest_' + nestn + '_'; }
if sym^.parcount = -2 then
pref := '*' + pref;
end;
(* process a list of qualifiers and modifiers *)
repeat
(* additional identifiers (field names) *)
if idok and (toktype = identifier) then
begin
lv := lv + ltok;
gettok;
idok := false;
end
else
(* pointers *)
if tok = '^' then
begin
pref := '*' + pref;
gettok;
end
else
(* pointer subscripts *)
if tok = '^[' then
begin
pref := '*{?}' + pref; {should this be here?}
lv := lv + '[';
gettok;
while tok <> ']' do
begin
lv := lv + pexpr;
if tok = ',' then
begin
lv := lv + '][';
gettok;
end;
end;
lv := lv + ']';
gettok;
end
else
(* pointer members *)
if tok = '^.' then
begin
lv := lv + '->';
gettok;
idok := true;
end
else
(* record members *)
if tok = '.' then
begin
if pref = '*' then {translate *id. into id->}
begin
pref := '';
lv := lv + '->';
end
else
lv := lv + '.';
idok := true;
gettok;
end
else
(* subscripts *)
if tok = '[' then
begin
sym := locatesym(lv);
if copy(pref,1,1) = '*' then
pref := ''; {replace '*id[' with 'id['}
lv := lv + '[';
gettok;
while tok <> ']' do
begin
lv := lv + pexpr;
if sym <> nil then
if sym^.symtype = s_string then
lv := lv + '-1';
if tok = ',' then
begin
lv := lv + '][';
gettok;
end;
end;
lv := lv + ']';
gettok;
end
else
(* function calls *)
if tok = '(' then
begin
func := findsym(globals, v);
pvars := 0;
if func <> nil then
pvars := func^.pvar;
lv := lv + '(';
gettok;
while tok <> ')' do
begin
ind := '';
if (pvars and 1) = 1 then
ind := '&';
tv := pexpr;
if ind = '&' then {var parameter? pass pointer}
begin
if tv[1] = '*' then {address of pointer deref is ptr}
begin
delete(tv,1,1);
ind := '';
end
else
if tv[1] in ['a'..'z','A'..'Z'] then
begin {pass pointer to strings/arrays}
sym := locatesym(tv);
if sym <> nil then
if (sym^.symtype = s_string) or
(sym^.suptype = ss_array) then
ind := '';
end;
{ else
ind := ''; }
end;
lv := lv + ind + tv;
pvars := pvars shr 1;
if (tok = ',') or (tok = ':') then
begin
lv := lv + ', ';
gettok;
end;
end;
lv := lv + ')';
gettok;
end
else
(* otherwise just return what was found so far *)
begin
(* add dummy param list to function calls where the proc
expects no parameters *)
sym := locatesym(lv);
if sym <> nil then
begin
if sym^.parcount = 0 then
lv := lv + '()'
else
if sym^.parcount > 0 then
if not iscall(lv) then
lv := lv + '()';
end;
if v = 'PARAMCOUNT' then
lv := '(argc-1)'
else
if v = 'PARAMSTR' then
lv := 'argv[' + copy(lv,10,length(lv)-10) + ']';
plvalue := pref + lv;
exit;
end;
until true=false;
end;